home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / REXX.LSP < prev    next >
Lisp/Scheme  |  1994-02-05  |  6KB  |  152 lines
  1. ;;;; Rexx Funktionen für CLISP
  2. ;;;; Jörg Höhle 27.11.1992
  3.  
  4. (in-package "LISP")
  5. (export '(rexx-run-command rexx-send-command rexx-wait-sent-command rexx-do-command
  6.           rexx-loop
  7. )        )
  8.  
  9. ;;;; Interface:
  10. ;;;
  11. ;;; (rexx-loop)
  12. ;;;
  13. ;;; (rexx-run-command name) -> null
  14. ;;;
  15. ;;; (rexx-do-command name) -> (rc result)
  16. ;;;
  17. ;;; (rexx-send-command name) -> handle
  18. ;;; (rexx-wait-sent-command handle) -> (rc result)
  19. ;;;
  20. ;;; name kann ein String (Kommandos in einem String)
  21. ;;;      oder ein Pathname (File mit Kommandos) sein.
  22. ;;; rc ist der ARexx return Code.
  23. ;;; result ist der ARexx return String, nur wenn rc gleich 0.
  24.  
  25. ;;;; ===========================================================================
  26. ;;;; Implementation:
  27.  
  28. (in-package "SYSTEM")
  29.  
  30. ;;; Wir benutzen folgende Funktionen aus REXX.D:
  31. ;;; (system::%rexx-wait-input) -> boolean
  32. ;;; (system::%rexx-get) -> (handle string) oder (handle rc [result])
  33. ;;; (system::%rexx-reply handle rc result) -> null
  34. ;;; (system::%rexx-put name :result :string :token :async :io) -> handle
  35. ;;; Keyword-Argumente result, string, token, async, io sind Flags:
  36. ;;; result: Antwort merken
  37. ;;; string: Argument als Befehle statt 1. Token als Dateiname verstehen
  38. ;;; token: Tokens erzeugen
  39. ;;; async: An AREXX statt REXX Port schicken, für asynchrone Bearbeitung
  40. ;;; io: E/A Kanäle übernehmen
  41.  
  42. ;; Wir verwalten eine Aliste  msg -> reply  aller weggeschickten und noch
  43. ;; unbearbeiteten Messages und ihrer Antworten (Listen (Code String);
  44. ;; NIL für noch unbeantwortete Messages). Beim Abschicken einer Message
  45. ;; bekommen wir ein "handle" als Erkennungszeichen (diese werden
  46. ;; mit EQUAL verglichen).
  47.  
  48. (defvar *rexx-outmsg-list* '())
  49.  
  50. (defun rexx-add-index (handle &optional (value nil))
  51.   (push (cons handle value) *rexx-outmsg-list*)
  52. )
  53. (defun rexx-find-index (handle)
  54.   (assoc handle *rexx-outmsg-list* :test #'equal)
  55. )
  56. (defun rexx-delete-entry (acons)
  57.   (setq *rexx-outmsg-list* (delete acons *rexx-outmsg-list* :test #'eq))
  58. )
  59.  
  60. ;; Startet ein REXX-Kommando, ohne jedoch jetzt auf dessen Beendigung zu warten.
  61. ;; Liefert das Handle, damit man später noch auf seine Beendigung warten kann,
  62. ;; jedoch NIL, falls das Kommando nicht erfolgreich abgeschickt werden konnte.
  63. (defun rexx-send-command (name &rest keys &key result string token async io)
  64.   (declare (ignore result string token async io))
  65.   "Starts asynchronous execution of a rexx command."
  66.   (let ((handle (apply #'%rexx-put name keys)))
  67.     (when handle
  68.       (rexx-add-index handle)
  69.       handle
  70. ) ) )
  71.  
  72. ;; Wartet auf die nächste Nachricht und liefert ihr Handle.
  73. (defun rexx-next-event ()
  74.   (loop ; es fehlt derzeit die Möglichkeit, parallel *STANDARD-INPUT* zu lesen
  75.     ; nächste Nachricht lesen und auswerten, falls vorhanden:
  76.     (let ((event (%rexx-get)))
  77.       (when event (return event))
  78.     )
  79.     ; auf die nächste Nachricht warten:
  80.     (%rexx-wait-input)
  81. ) )
  82.  
  83. ;; "Hauptschleife": Wartet auf Nachrichten, interpretiert diese als Fragen,
  84. ;; wertet sie aus und schickt die Antwort zurück. Die Schleife wird beendet,
  85. ;; wenn eine Antwort auf Handle wait-for kommt.
  86. (defun rexx-loop (&optional wait-for)
  87.   "Rexx driver loop. Optional message to wait for."
  88.   (driver ; driver oder einfaches loop ??
  89.     #'(lambda ()
  90.         (let ((event (rexx-next-event))) ; nächste Nachricht
  91.           (cond ((numberp (second event)) ; ein Reply (handle rc [result])
  92.                  (let ((index (rexx-find-index (first event))))
  93.                    (when index (setf (cdr index) (rest event))) ; Antwort abspeichern
  94.                  )
  95.                  (when (equal (first event) wait-for)
  96.                    (return-from rexx-loop (rest event)) ; evtl. Schleife beenden
  97.                 ))
  98.                 (t ; ein Befehl (handle string)
  99.                  (let ((result nil))
  100.                    ; warum funktioniert (catch 'debug ...) nicht??
  101.                    (unwind-protect
  102.                      (block try-rep ; Fehlerbehandlung
  103.                        (setq result
  104.                          (with-output-to-string (stream)
  105.                            (let ((*error-handler*
  106.                                    #'(lambda (&rest error-args)
  107.                                        (declare (ignore error-args))
  108.                                        (return-from try-rep nil)
  109.                                 ))   )
  110.                              ; primitives READ-EVAL-PRINT :
  111.                              (princ (eval (read-from-string (second event)))
  112.                                     stream
  113.                      ) ) ) ) )
  114.                      (%rexx-reply (first event) (if result 0 5) result) ; portabler machen!??
  115.                 )) )
  116. ) )   ) ) )
  117.  
  118. ;; Wartet auf die Beendigung eines REXX-Kommandos.
  119. ;; Liefert die Antwort (eine Liste (Code String)).
  120. (defun rexx-wait-sent-command (handle)
  121.   "Waits for command termination."
  122.   (loop
  123.     (let ((done (rexx-find-index handle)))
  124.       (unless done
  125.         (error #+DEUTSCH "Kein Warten auf ~S möglich."
  126.                #+ENGLISH "No waiting for ~S possible."
  127.                #+FRANCAIS "Pas d'attente de ~S possible."
  128.                handle
  129.       ) )
  130.       (when (cdr done) (rexx-delete-entry done) (return (cdr done)))
  131.       (rexx-loop handle) ; auf die Antwort warten, Aussprung oben
  132. ) ) )
  133.  
  134. ;; Startet ein REXX-Kommando und wartet, bis es beendet ist.
  135. ;; Liefert die Antwort (eine Liste (Code String)),
  136. ;; jedoch NIL, falls das Kommando nicht erfolgreich abgeschickt werden konnte.
  137. (defun rexx-do-command (name &rest keys &key &allow-other-keys)
  138.   "Executes command, waiting for result."
  139.   (let ((handle (apply #'rexx-send-command name keys)))
  140.     (when handle
  141.       (rexx-wait-sent-command handle)
  142. ) ) )
  143.  
  144. ;; Startet ein REXX-Kommando, ohne jedoch auf dessen Beendigung zu warten
  145. ;; (asynchron).
  146. ;; Liefert /=NIL, falls das Kommando erfolgreich abgeschickt wurde.
  147. (defun rexx-run-command (name &key string token)
  148.   "Runs a rexx command asynchronously, no return code."
  149.   (if (rexx-do-command name :string string :token token :async t) t nil)
  150. )
  151.  
  152.